The Atari Compendium/The Atari Compendium (Toad Computers) (1994).iso/files/prgtools/langs/pcl-src.zoo/ibcl-low.lsp

Text File | 1992-07-09 | 11.2 KB | 333 lines

;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to [e-mail])
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; The version of low for Kyoto Common Lisp (KCL)
(in-package 'pcl)

;;;
;;; The reason these are here is because the KCL compiler does not allow
;;; LET to return FIXNUM values as values of (c) type int, hence the use
;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces
;;; conversion of ints to objects.
;;;
(defmacro %logand (&rest args)
  (reduce-variadic-to-binary 'logand args 0 t 'fixnum))

;(defmacro %logxor (&rest args)
;  (reduce-variadic-to-binary 'logxor args 0 t 'fixnum))

(defmacro %+ (&rest args)
  (reduce-variadic-to-binary '+ args 0 t 'fixnum))

;(defmacro %- (x y)
;  `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))

(defmacro %* (&rest args)
  (reduce-variadic-to-binary '* args 1 t 'fixnum))

(defmacro %/ (x y)
  `(the fixnum (/ (the fixnum ,x) (the fixnum ,y))))

(defmacro %1+ (x)
  `(the fixnum (1+ (the fixnum ,x))))

(defmacro %1- (x)
  `(the fixnum (1- (the fixnum ,x))))

(defmacro %svref (vector index)
  `(svref (the simple-vector ,vector) (the fixnum ,index)))

(defsetf %svref (vector index) (new-value)
  `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
         ,new-value))


;;;
;;; std-instance-p
;;;
(si:define-compiler-macro std-instance-p (x)
  (once-only (x)
    `(and (si:structurep ,x)
      (eq (si:structure-name ,x) 'std-instance))))

(import 'si:structurep)

(defmacro structure-type (x)
  `(si:structure-name ,x))

(dolist (inline '((si:structurep
            ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
            compiler::inline-always)
          (si:structure-name
            ((t) t nil nil "(#0)->str.str_name")
            compiler::inline-unsafe)))
  (setf (get (first inline) (third inline)) (list (second inline))))

(setf (get 'cclosure-env 'compiler::inline-always)
      (list '((t) t nil nil "(#0)->cc.cc_env")))

;;;
;;; turbo-closure patch.  See the file kcl-mods.text for details.
;;;
#+:turbo-closure
(progn
(CLines
  "object tc_cc_env_nthcdr (n,tc)"
  "object n,tc;                        "
  "{return (type_of(tc)==t_cclosure&&  "
  "         tc->cc.cc_turbo!=NULL&&    "
  "         type_of(n)==t_fixnum)?     "
  "         tc->cc.cc_turbo[fix(n)]:   " ; assume that n is in bounds
  "         Cnil;                      "
  "}                                   "
  )

(defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr))

(setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe)
      '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")))
)


;;;; low level stuff to hack compiled functions and compiled closures.
;;;
;;; The primary client for this is fsc-low, but since we make some use of
;;; it here (e.g. to implement set-function-name-1) it all appears here.
;;;

(eval-when (compile eval)

(defmacro define-cstruct-accessor (accessor structure-type field value-type
                        field-type tag-name)
  (let ((setf (intern (concatenate 'string "SET-" (string accessor))))
    (caccessor (format nil "pcl_get_~A_~A" structure-type field))
    (csetf     (format nil "pcl_set_~A_~A" structure-type field))
    (vtype (intern (string-upcase value-type))))
    `(progn
       (CLines ,(format nil "~A ~A(~A)                ~%~
                             object ~A;               ~%~
                             { return ((~A) ~A->~A.~A); }       ~%~
                                                      ~%~
                             ~A ~A(~A, new)           ~%~
                             object ~A;               ~%~
                             ~A new;                  ~%~
                             { return ((~A)(~A->~A.~A = ~Anew)); } ~%~
                            "
            value-type caccessor structure-type
            structure-type
            value-type structure-type tag-name field
            value-type csetf structure-type
            structure-type
            value-type
            value-type structure-type tag-name field field-type
            ))

       (defentry ,accessor (object) (,vtype ,caccessor))
       (defentry ,setf (object ,vtype) (,vtype ,csetf))


       (defsetf ,accessor ,setf)

       )))
)
;;;
;;; struct cfun {                   /*  compiled function header  */
;;;         short   t, m;
;;;         object  cf_name;        /*  compiled function name  */
;;;         int     (*cf_self)();   /*  entry address  */
;;;         object  cf_data;        /*  data the function uses  */
;;;                                 /*  for GBC  */
;;;         char    *cf_start;      /*  start address of the code  */
;;;         int     cf_size;        /*  code size  */
;;; };
;;; add field-type tag-name
(define-cstruct-accessor cfun-name  "cfun" "cf_name"  "object" "(object)" "cf")
(define-cstruct-accessor cfun-self  "cfun" "cf_self"  "int" "(int (*)())"
                         "cf")
(define-cstruct-accessor cfun-data  "cfun" "cf_data"  "object" "(object)" "cf")
(define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf")
(define-cstruct-accessor cfun-size  "cfun" "cf_size"  "int" "(int)" "cf")

(CLines
  "object pcl_cfunp (x)              "
  "object x;                         "
  "{if(x->c.t == (int) t_cfun)       "
  "  return (Ct);                    "
  "  else                            "
  "    return (Cnil);                "
  "  }                               "
  )

(defentry cfunp (object) (object pcl_cfunp))

;;;
;;; struct cclosure {               /*  compiled closure header  */
;;;         short   t, m;
;;;         object  cc_name;        /*  compiled closure name  */
;;;         int     (*cc_self)();   /*  entry address  */
;;;         object  cc_env;         /*  environment  */
;;;         object  cc_data;        /*  data the closure uses  */
;;;                                 /*  for GBC  */
;;;         char    *cc_start;      /*  start address of the code  */
;;;         int     cc_size;        /*  code size  */
;;; };
;;;
(define-cstruct-accessor cclosure-name "cclosure"  "cc_name"  "object"
                         "(object)" "cc")
(define-cstruct-accessor cclosure-self "cclosure"  "cc_self"  "int"
                         "(int (*)())" "cc")
(define-cstruct-accessor cclosure-data "cclosure"  "cc_data"  "object"
                          "(object)" "cc")
(define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int"
                         "(char *)" "cc")
(define-cstruct-accessor cclosure-size "cclosure"  "cc_size"  "int"
             "(int)" "cc")
(define-cstruct-accessor cclosure-env "cclosure"   "cc_env"   "object"
                         "(object)" "cc")


(CLines
  "object pcl_cclosurep (x)          "
  "object x;                         "
  "{if(x->c.t == (int) t_cclosure)   "
  "  return (Ct);                    "
  "  else                            "
  "   return (Cnil);                 "
  "  }                               "
  )

(defentry cclosurep (object) (object pcl_cclosurep))

  ;;
;;;;;; Load Time Eval
  ;;
;;;

;;; This doesn't work because it looks at a global variable to see if it is
;;; in the compiler rather than looking at the macroexpansion environment.
;;;
;;; The result is that if in the process of compiling a file, we evaluate a
;;; form that has a call to load-time-eval, we will get faked into thinking
;;; that we are compiling that form.
;;;
;;; THIS NEEDS TO BE DONE RIGHT!!!
;;;
;(defmacro load-time-eval (form)
;  ;; In KCL there is no compile-to-core case.  For things that we are
;  ;; "compiling to core" we just expand the same way as if were are
;  ;; compiling a file since the form will be evaluated in just a little
;  ;; bit when gazonk.o is loaded.
;  (if (and (boundp 'compiler::*compiler-input*)  ;Hack to see of we are
;       compiler::*compiler-input*)          ;in the compiler!
;      `'(si:|#,| . ,form)
;      `(progn ,form)))

(defmacro load-time-eval (form)
  (read-from-string (format nil "'#,~S" form)))

(defmacro memory-block-ref (block offset)
  `(svref (the simple-vector ,block) (the fixnum ,offset)))

  ;;
;;;;;; Generating CACHE numbers
  ;;
;;; This needs more work to be sure it is going as fast as possible.
;;;   -  The calls to si:address should be open-coded.
;;;   -  The logand should be open coded.
;;;

;(defmacro symbol-cache-no (symbol mask)
;  (if (and (constantp symbol)
;       (constantp mask))
;      `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask))
;      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))

(defmacro object-cache-no (object mask)
  `(logand (the fixnum (si:address ,object)) ,mask))

  ;;
;;;;;; printing-random-thing-internal
  ;;
(defun printing-random-thing-internal (thing stream)
  (format stream "~O" (si:address thing)))


(defun set-function-name-1 (fn new-name ignore)
  (cond ((cclosurep fn)
     (setf (cclosure-name fn) new-name))
    ((cfunp fn)
     (setf (cfun-name fn) new-name))
    ((and (listp fn)
          (eq (car fn) 'lambda-block))
     (setf (cadr fn) new-name))
    ((and (listp fn)
          (eq (car fn) 'lambda))
     (setf (car fn) 'lambda-block
           (cdr fn) (cons new-name (cdr fn)))))
  fn)




#|
(defconstant most-positive-small-fixnum 1024)  /* should be supplied */
(defconstant most-negative-small-fixnum -1024) /* by ibuki */

(defmacro symbol-cache-no (symbol mask)
  (if (constantp mask)
      (if (and (> mask 0)
           (< mask most-positive-small-fixnum))
      (if (constantp symbol)
          `(load-time-eval (coffset ,symbol ,mask 2))
        `(coffset ,symbol ,mask 2))
    (if (constantp symbol)
        `(load-time-eval
           (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))
      `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))
    `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)))


(defmacro object-cache-no (object mask)
  (if (and (constantp mask)
       (> mask 0)
       (< mask most-positive-small-fixnum))
      `(coffset ,object ,mask 4)
    `(logand (ash (the fixnum (si:address ,object)) -4) ,mask)))

(CLines
  "object pcl_coffset (sym,mask,lshift)"
  "object sym,mask,lshift;"
  "{"
  "    return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));"
  "}"
  )

(defentry coffset (object object object) (object pcl_coffset))


|#